home *** CD-ROM | disk | FTP | other *** search
/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 04 - 1988 / 04.03 Mar 88 / Forth Column / Reminder.fth edit < prev   
Encoding:
Text File  |  1988-01-26  |  8.6 KB  |  363 lines  |  [TEXT/EDIT]
  1. \ ***** Time manager example - a 'reminder' utility
  2. \ J. Langowski December 87 
  3. \
  4. \ Strategy: write a driver that sets up a dialog which allows 
  5. \ to enter a time & message to display after that time. After 
  6. \ the appointment has been entered, the driver sets up a 
  7. \ time manager call for that appointment.
  8. \ The time manager routine installs a SystemTask trap patch
  9. \ which at the next occasion will draw an alert box containing
  10. \ the message to be displayed. 
  11. \
  12. \ Note that we have to use the patch rather than calling 
  13. \ the alert routine directly from our time manager task,
  14. \ since we can't be sure we're not in the middle of a 
  15. \ memory manager operation when it is called.
  16. \
  17.  
  18. only forth also assembler also mac
  19.  
  20. CODE InsTime ( tmTaskPtr | -- )
  21.     MOVE.L (A6)+,A0
  22.     _InsTime
  23.     RTS
  24. END-CODE MACH
  25.  
  26. CODE PrimeTime ( tmTaskPtr count | -- )
  27.     MOVE.L (A6)+,D0
  28.     MOVE.L (A6)+,A0
  29.     _PrimeTime
  30.     RTS
  31. END-CODE MACH
  32.  
  33. CODE RmvTime ( tmTaskPtr | -- )
  34.     MOVE.L (A6)+,A0
  35.     _RmvTime
  36.     RTS
  37. END-CODE MACH
  38.  
  39. 4ascii MENU constant "menu
  40. 4ascii PROC constant "proc
  41.  
  42. \ *** compiler support words for external definitions *** 
  43. : :xdef 
  44.     create     -4 allot
  45.         $4EFA w, ( JMP )
  46.         0 w,     ( entry point to be filled later )
  47.         0 ,      ( length of routine to be filled later )
  48.         here 6 - 76543
  49. ;
  50.  
  51. : ;xdef { branch marker entry | -- }
  52.     marker 76543 <> abort" xdef mismatch"
  53.     entry branch - branch w!
  54.     here branch - 2+ branch 2+ !
  55. ; 
  56.     
  57. : xlen 4 + @ ; ( get length word of external definition )
  58.  
  59. ( *** driver header block *** )
  60.  
  61.  0 CONSTANT drvrFlags
  62.  2 CONSTANT drvrdelay 
  63.  4 CONSTANT drvrEMask
  64.  6 CONSTANT drvrMenu
  65.  8 CONSTANT drvrOpen
  66. 10 CONSTANT drvrPrime
  67. 12 CONSTANT drvrCtl
  68. 14 CONSTANT drvrStatus
  69. 16 CONSTANT drvrClose
  70. 18 CONSTANT drvrname
  71. 50 CONSTANT DAlength
  72.  
  73. \ *** compiler support words for DA and driver definitions ***
  74. : :DA 
  75.     create     -4 allot
  76.         here 87654 ( start of DA block, and marker )
  77.         50 allot   ( length of block )
  78. ;
  79.  
  80. : ;DA { DAstart marker Ropen Rprime Rctl Rstatus Rclose
  81.         Rflags Rdelay Remask Rmenu Rname | -- }
  82.     marker 87654 <> abort" DA definition mismatch"
  83.     Ropen     DAStart - DAStart drvrOpen + w!
  84.     Rprime     DAStart - DAStart drvrPrime + w!
  85.     Rctl         DAStart - DAStart drvrCtl + w!
  86.     Rstatus     DAStart - DAStart drvrStatus + w!
  87.     Rclose     DAStart - DAStart drvrClose + w!
  88.     Rflags          DAStart drvrFlags + w!
  89.     Rdelay          DAStart drvrDelay + w!
  90.     Remask          DAStart drvrEmask + w!
  91.     RMenu              DAStart drvrMenu + w!
  92.     Rname count dup      DAStart drvrName + c!
  93.         DAStart drvrName + 1+ swap 
  94.         dup 31 > if drop 31 then cmove 
  95.     here DAstart -       DAStart DAlength + !
  96. ; 
  97.     
  98. : DAlen DAlength + @ ; ( get length word of external definition )
  99.  
  100. \ **** DA glue macros
  101.  
  102. CODE DA.prelude
  103.     LINK    A6,#-512        \ 512 bytes of local Forth stack
  104.     MOVEM.L     A0-A1,-(A7)    \ save registers
  105.     MOVE.L      A6,A3        \ setup local loop return stack
  106.     SUBA.L   #256,A3         \ in the low 256 local stack bytes
  107.     MOVE.L      A0,-(A6)     \ parameter block
  108.     MOVE.L      A1,-(A6)    \ device control entry
  109.     RTS                        \ just to indicate the MACHro stops here 
  110. END-CODE MACH
  111.  
  112. CODE DA.epilogue
  113.     MOVE.L      (A6)+,D0    \ return code
  114.     MOVEM.L     (A7)+,A0-A1    \ restore registers
  115.     UNLK        A6
  116.     RTS
  117. END-CODE MACH
  118.  
  119. CODE DA.Jiodone
  120.     MOVE.L      (A6)+,D0    \ return code
  121.     MOVEM.L     (A7)+,A0-A1    \ restore registers
  122.     UNLK        A6
  123.     move.l        JIODone,A0
  124.     movem.l     d4-d7/a4-a6,-(a7)
  125.     jsr            (a0)
  126.     movem.l    (a7)+,d4-d7/a4-a6
  127.     RTS
  128. END-CODE MACH
  129.  
  130. .TRAP    _newptr,sys    $A51E
  131.  
  132. %0000000101001010 CONSTANT DAEmask
  133.  
  134. $1B4 CONSTANT SystemTask
  135.  
  136. \ __________________________________________________
  137. \ time manager and systemTask patch routine
  138. \ this routine must reside in a block allocated 
  139. \ in the system heap through a pointer. 
  140. \ __________________________________________________
  141.  
  142. header myTask 14 allot
  143. 6 CONSTANT taskPtr
  144. HEADER myName
  145.     DC.B     9,0,'Reminder'
  146. header myTrap 4 allot
  147. header myAlert 4 allot
  148. header myString 256 allot
  149.  
  150. : alertMe 
  151.     MOVEM.L    A0-A4/A6/D0-D7,-(A7)
  152.     LINK    A6,#-128    \ 128 bytes of local Forth stack
  153.     (call) frontwindow windowkind + @
  154.     2 <> IF
  155.         ['] myTrap @ SystemTask (call) SetTrapAddress
  156.         ['] myString 0 0 0 (call) paramText
  157.         ['] myAlert @ 0 (call) noteAlert drop
  158.         ['] myAlert @ (call) freeAlert
  159.         ['] myTask RmvTime
  160.         ['] myTask (call) DisposPtr drop
  161.     THEN
  162.     UNLK    A6
  163.     MOVEM.L    (A7)+,A0-A4/A6/D0-D7
  164. ;
  165.  
  166. : wakeMe
  167.     SystemTask (call) GetTrapAddr ['] myTrap !
  168.     ['] alertMe SystemTask (call) SetTrapAddr
  169. ;
  170.  
  171. header mytask.end
  172. ' wakeme ' mytask - CONSTANT *wakeme \ task offset
  173. ' myAlert ' mytask - CONSTANT *myAlert \ alertID 
  174. ' myString ' mytask - CONSTANT *myString \ alert string
  175.  
  176. \ ___________________________________________
  177. \ desk accessory code starts here.
  178. \ ___________________________________________
  179.  
  180. :DA reminder 
  181.     .ALIGN
  182.  
  183. ( *** main desk accessory routines *** )
  184. header myRes0 4 allot        \ local res ID=0 offset 
  185. header dlgText 256 allot
  186.  
  187. \ redefinition of cmove to make it 
  188. \ available locally
  189.  
  190. CODE cmove
  191.     move.l    (a6)+,d0
  192.     move.l    (a6)+,a1
  193.     move.l    (a6)+,a0
  194.     tst.l    d0
  195.     ble.s    @2
  196. @1    move.b    (a0)+,(a1)+
  197.     subq.l    #1,d0
  198.     bne.s    @1
  199. @2    rts
  200. END-CODE
  201.  
  202. \ ___________________
  203. \ wakeup routine installation
  204. \ ___________________
  205.  
  206. : install.wakeup 
  207.     { delay alrtID msg | procHdl hSize taskBlock -- }
  208.  
  209.     "proc ['] myRes0 @ (call) GetResource -> procHdl
  210.     procHdl (call) getHandleSize -> hSize
  211.         hSize MOVE.L (A6)+,D0
  212.         _newPtr,sys
  213.         MOVE.L    A0,-(A6) -> taskBlock
  214.     procHdl @ taskBlock hSize cmove
  215.     procHdl (call) releaseResource
  216.         \ we have made a local copy of the wakeup routine
  217.     taskBlock dup *wakeMe + swap taskPtr + !
  218.         msg taskBlock *myString + 256 cmove
  219.         alrtID taskBlock *myAlert + !
  220.         alrtID (call) CouldAlert
  221.     taskBlock InsTime
  222.     taskBlock delay PrimeTime
  223.         \ now the wakeup routine will wake up after
  224.         \ the scheduled delay.
  225. ;
  226.  
  227. : getDrvrID { dCtlEntry | -- num }
  228.     dCtlEntry dCtlRefNum + w@ l_ext
  229.     1+ negate
  230. ;
  231.  
  232. : ownResID ( resID drvrID )
  233.     5 shl + -16384 +
  234. ;
  235.  
  236. : Open { parblk dce | DAWind Res0 -- returncode }
  237.     5 (call) sysbeep 
  238.         \ to get attention if automatically opened
  239.     0 dce getDrvrID ownResID -> Res0
  240.     dce dCtlWindow + @ -> DAWind
  241.     DAWind 0= IF ( not open already )
  242.         Res0 ['] myRes0 !
  243.         Res0 0 -1 (call) getNewDialog -> DAWind
  244.         DAWind  dce dCtlWindow + !  \ store dialog pointer
  245.         DAWind  dce dCtlRefNum + w@  swap windowKind + w!
  246.     ELSE
  247.         DAWind (call) selectWindow
  248.     THEN
  249.     0
  250. ;
  251.  
  252. : Close { parblk dce | -- returncode }
  253.     dce dCtlWindow + 
  254.     dup @ (call) DisposDialog  
  255.         0 swap ! ( so that Open will work again )
  256.     0
  257. ;
  258.  
  259. : dialog-handler 
  260.     { dlgPtr itemHit | 
  261.         itemType hItem rBox seconds -- }
  262.  
  263. \ we get here if the OK button in the dialog
  264. \ has been hit, therefore itemHit is always =1 
  265. \ - in our case. But it is nice to have itemHit
  266. \ available, to be more general. 
  267. \ item #3 contains the appointment message
  268. \ item #4 contains the delay in seconds
  269. \ (decimal number string)
  270.  
  271.     dlgPtr 4 ^ itemType ^ hItem ^ rBox (call) GetDItem
  272.     hItem ['] dlgText (call) GetIText
  273.     ['] dlgText (call) StringToNum -> seconds
  274.     seconds 0> IF
  275.         dlgPtr 3 ^ itemType ^ hItem ^ rBox 
  276.                             (call) GetDItem
  277.         hItem ['] dlgText (call) GetIText
  278.         seconds 1000 w* 
  279.             ['] myres0 @ ['] dlgText install.wakeup        
  280.         ELSE 10 (call) sysbeep
  281.         THEN
  282. ;
  283.  
  284. : Ctl { parblk dce | DAWind event-rec dlgPtr itemHit -- returncode }
  285.     
  286.     dce dCtlWindow + @ -> DAWind
  287.  
  288.     parblk csCode + w@ l_ext 
  289.     CASE
  290.         accEvent OF
  291.             2 DAWind windowKind + w! \ set to dialog window 
  292.             parblk csParam + @ -> event-rec
  293.             event-rec (call) IsDialogEvent
  294.             IF  event-rec ^ dlgPtr ^ itemHit
  295.                 (call) Dialogselect
  296.                 IF dlgPtr itemHit dialog-handler THEN
  297.             THEN
  298.             DAWind  dce dCtlRefNum + w@  
  299.                 swap windowKind + w! \ reset windowkind
  300.         ENDOF
  301.  
  302.     ENDCASE
  303.     0
  304. ;
  305.  
  306.  
  307. : DrOpen DA.Prelude Open DA.Epilogue ;
  308. : DrClose DA.Prelude Close DA.Epilogue ;
  309. : DrCtl DA.Prelude Ctl DA.JioDone ;
  310. : DrStatus ;
  311. : DrPrime ;
  312.  
  313. ' DrOpen ' DrPrime ' DrCtl ' DrStatus ' DrClose
  314. $7400 \ need lock, need time, need goodbye, ctl calls
  315. 60 DAEmask 0 \ delay mask menu
  316. " Reminder" \ name
  317. ;DA
  318.  
  319.  
  320. ( write resource to file ) 
  321. : $create-res ( str-addr - errcode )
  322.     call CreateResFile
  323.     call ResError L_ext
  324. ;
  325.  
  326. : $open-res { addr | refNum - refNum or errcode }
  327.     addr call OpenResFile -> refNum
  328.     call ResError L_ext
  329.     ?dup IF ELSE refNum THEN
  330. ; 
  331.  
  332. : close-res ( refNum - errcode )
  333.     call CloseResFile
  334.     call ResError L_ext
  335. ;
  336.  
  337. : make-res { addr len rtype ID name | -- }
  338.     addr len call PtrToHand 
  339.     abort" Could not create resource handle"
  340.     rtype ID name call AddResource
  341. ;
  342.  
  343. : write-out { filename | refnum -- } 
  344.     filename $create-res abort" That resource file already exists"
  345.     filename $open-res
  346.     dup 0< abort" Open resource file failed"
  347.     -> refnum
  348.     refnum call UseResFile
  349.     ['] reminder dup DALen
  350.         "drvr 12 " Reminder" make-res
  351.     ['] myTask ['] mytask.end over - 
  352.         "proc -16000 " wakeUp" make-res
  353.         "proc -16000 call GetResource
  354.         dup 80 call SetResAttrs  ( 64: sysheap + 16: locked )
  355.         call ChangedResource
  356.     refnum close-res abort" Could not close resource file"
  357. ;
  358.  
  359. : make-DA
  360.     " Reminder.rsrc" $delete drop
  361.     " Reminder.rsrc" write-out
  362. ;
  363.